home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / heap55.com / GRABHEAP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1990-01-07  |  2.6 KB  |  95 lines
  1. {*****************************************************************************
  2.  This unit lets a program take control of the standard operations for New,
  3.  GetMem, Dispose, FreeMem from the SYSTEM unit. USE it anywhere in a program's
  4.  USES list. You must call the routine CustomHeapControl in order to grab
  5.  control.
  6.  
  7.  For further information about this unit, refer to HEAP.DOC.
  8.  
  9.  Written 7/18/88, Kim Kokkonen, TurboPower Software.
  10.  Compuserve ID 76004,2611
  11.  Released to the public domain.
  12.  
  13.  Version 1.0
  14.    First release.
  15.  Version 5.0
  16.    For consistency with 5.0 release of other heap utilities.
  17.  Version 5.5, 1/6/90
  18.    Updated for Turbo Pascal 5.5
  19. *****************************************************************************}
  20.  
  21. {$R-,S-,B-,F-}
  22.  
  23. unit GrabHeap;
  24.  
  25. interface
  26.  
  27. type
  28.   GetMemFunc = function(Size : Word) : pointer;
  29.   FreeMemProc = procedure(P : Pointer; Size : Word);
  30.  
  31. procedure CustomHeapControl(GetPtr : GetMemFunc; FreePtr : FreeMemProc);
  32.   {-Give control of GetMem, New, FreeMem, Dispose to specified procedures}
  33.  
  34. procedure SystemHeapControl;
  35.   {-Restore control to the system heap routines}
  36.  
  37.   {===============================================================}
  38.  
  39. implementation
  40.  
  41. type
  42.   Xfer = record
  43.            Instr : Byte;
  44.            Addr : Pointer;
  45.          end;
  46. var
  47.   P : ^Byte;
  48.   GetMemPtr : ^Xfer;
  49.   FreeMemPtr : ^Xfer;
  50.   GetSave : Xfer;
  51.   FreeSave : Xfer;
  52.  
  53.   procedure CustomHeapControl(GetPtr : GetMemFunc; FreePtr : FreeMemProc);
  54.   var
  55.     X : Xfer;
  56.   begin
  57.     with X do begin
  58.       Instr := $EA;               {JMP FAR}
  59.       Addr := @GetPtr;
  60.       GetMemPtr^ := X;
  61.       Addr := @FreePtr;
  62.       FreeMemPtr^ := X;
  63.     end;
  64.   end;
  65.  
  66.   procedure SystemHeapControl;
  67.   begin
  68.     GetMemPtr^ := GetSave;
  69.     FreeMemPtr^ := FreeSave;
  70.   end;
  71.  
  72.   function FindCsPtr(N : Word) : Pointer;
  73.     {-Return pointer in code segment N bytes before macro call}
  74.   inline
  75.   ($E8/$00/$00/                   {  call next}
  76.    $5F/                           {next:  pop  di}
  77.    $0E/                           {  push cs}
  78.    $07/                           {  pop  es}
  79.    $58/                           {  pop  ax}
  80.    $83/$EF/$07/                   {  sub  di,7}
  81.    $29/$C7/                       {  sub  di,ax}
  82.    $26/$C4/$05/                   {  les  ax,es:[di]}
  83.    $8C/$C2);                      {  mov  dx,es}
  84.  
  85. begin
  86.   {Find GetMem and FreeMem in SYSTEM}
  87.   New(P);
  88.   GetMemPtr := FindCsPtr(11);
  89.   Dispose(P);
  90.   FreeMemPtr := FindCsPtr(4);
  91.   {Save the first 5 bytes of each routine, which will be overwritten}
  92.   GetSave := GetMemPtr^;
  93.   FreeSave := FreeMemPtr^;
  94. end.
  95.